Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue54/Persist/tiPtnFactory.pas

Pascal/Delphi Source File | 2000-01-21 | 12.5 KB | 381 lines

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  TechInsite Pty. Ltd.
  PO Box 429, Abbotsford, Melbourne. 3067 Australia
  Phone: [phone]
  Fax:   [phone]
  Web:   www.techinsite.com.au
  EMail: [e-mail]

  Created: 01/12/1999

  Notes: Factory pattern.

* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}


{  Useage...

interface
uses
  tiPtnFactory
  ;

type

  TMyClass = class( TObject ) ;

  TMyConcrete1 = class( TMyClass ) ;
  TMyConcrete2 = class( TMyClass ) ;

  //----------------------------------------------------------------------------
  TMyFactory = class( TtiFactory )
  public
    Function  CreateInstance( const pStrClassID : string ) : TMyClass ;
  end;

function gMyFactory : TMyFactory ;

implementation
var
  uMyFactory : TMyFactory ;

function gMyFactory : TMyFactory ;
begin
  if uMyFactory = nil then
    uMyFactory := TMyFactory.Create ;
  result := uMyFactory ;
end ;

//----------------------------------------------------------------------------
function TMyFactory.CreateInstance( const pStrClassID: string): TMyClass ;
begin
  result := TMyClass( DoCreateInstance( pStrClassID )) ;
end;

implementation
  gMyFactory.RegisterClass( 'Name1', TMyConcrete1 ) ;
  gMyFactory.RegisterClass( 'Name2', TMyConcrete2 ) ;

finalization
  uMyFactory.Free ;

end.

}

unit tiPtnFactory ;

interface
uses
   Classes             // For TObject
  ;

type

  // Class reference for TObject descendants
  //----------------------------------------------------------------------------
  TObjectClassRef = class of TObject ;

  // Class reference for TComponent descendants
  //----------------------------------------------------------------------------
  TComponentClassRef = class of TComponent ;

  // Tell the factory to create a TObject or a TComponent.
  // This is necessary as TComponent descendents will need
  // an owner parameter.
  //----------------------------------------------------------------------------
  TCreateAs = ( caTObject, caTComponent ) ;

  // After a class is registered with the factory, a
  // TClassMappingAbstract descendant will be added to the
  // list of registered objects.
  //----------------------------------------------------------------------------
  TClassMappingAbstract = class( TObject )
  private
    FStrClassID : string ;      // A string to identify the class
    FCreateAs   : TCreateAs ;   // Create as a TObject or TComponent
    FBoolSingleton : boolean ;  // Cache this instance ?
  public
    property    ClassID  : string read  FStrClassID
                                  write FStrClassID ;
    property    CreateAs : TCreateAs read  FCreateAs
                                     write FCreateAs ;
    property    Singleton : boolean read FBoolSingleton
                                    write FBoolSingleton ;
  end ;

  // Used when a TObject descendant is registered
  //----------------------------------------------------------------------------
  TClassMappingObject = class( TClassMappingAbstract )
  private
    FClassRef     : TObjectClassRef ;  // TObject class reference
  public
    Constructor CreateExt( const pStrClassID : string ;
                  pClassRef : TObjectClassRef ;
                  const pBoolSingleton : boolean ) ;
    property    ClassRef : TObjectClassRef read FClassRef
                                           write FClassRef ;
  end ;

  // Used when a TComponent descendant is registered
  //----------------------------------------------------------------------------
  TClassMappingComponent = class( TClassMappingAbstract )
  private
    FClassRef     : TComponentClassRef ;  // TComponent class reference
  public
    Constructor CreateExt( const pStrClassID : string ;
                  pClassRef : TComponentClassRef ;
                  const pBoolSingleton : boolean ) ;
    property    ClassRef : TComponentClassRef read FClassRef
                                           write FClassRef ;
  end ;

  { ToDo 1 -cPatterns: Move the cache part of the factory to a flyweight pattern}
  // The abstract factory
  //----------------------------------------------------------------------------
  TtiFactory = class( TObject )
  private
    FClassMappings : TStringList ;  // List of registered classes
    FObjectCache   : TStringList ;  // Cache of already created objects
  protected
    // Create an instance of our class, or return a pointer to the existing
    // instance if already created. This function is protected to force
    // you to create a public implementation in a concrete class.
    Function   DoCreateInstance( const pStrClassID : string ; owner : TComponent = nil ) : TObject ; virtual ;
  public
    Constructor Create ; virtual ;
    Destructor  Destroy ; override ;
    // Register a TObject descendant
    Procedure   RegisterClass( const pStrClassID : string;
                              pClassRef : TObjectClassRef ;
                              const pBoolSingleton : boolean = false ) ; overload ;
    // Register a TComponent descendant
    Procedure   RegisterClass( const pStrClassID : string;
                              pClassRef : TComponentClassRef ;
                              const pBoolSingleton : boolean = false ) ; overload ;
    Property    ClassMappings : TStringList read FClassMappings ;

  end ;

implementation
uses
  SysUtils   // UpperCase
  ,Dialogs   // MessageDlg
  ;

// * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
// *
// * TClassMappingObject: Hold information about how to create a TObject
// *                      descendant.
// *
// * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
constructor TClassMappingObject.CreateExt(
                  const pStrClassID : string;
                  pClassRef: TObjectClassRef ;
                  const pBoolSingleton : boolean ) ;
begin
  Create ;
  ClassID  := pStrClassID ;
  ClassRef := pClassRef  ;
  CreateAs := caTObject ;
  Singleton := pBoolSingleton ;
end;

// * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
// *
// * TClassMappingComponent: Hold information about how to create a
// *                         TComponent descendant.
// *
// * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
constructor TClassMappingComponent.CreateExt(
                  const pStrClassID: string;
                  pClassRef: TComponentClassRef ;
                  const pBoolSingleton : boolean ) ;
begin
  Create ;
  ClassID  := pStrClassID ;
  ClassRef := pClassRef  ;
  CreateAs := caTComponent ;
  Singleton := pBoolSingleton ;
end;

// * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
// *
// * TFactoryAbstract: The abstract factory.
// *                   Used to create TObject and TComponent descendants.
// *
// * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
constructor TtiFactory.Create;
begin
  inherited ;
  FClassMappings := TStringList.Create ;
  FObjectCache   := TStringList.Create ;
end;

//------------------------------------------------------------------------------
destructor TtiFactory.Destroy;
var i : integer ;
begin

  // Scan through FClassMappings,
  // and free any associated objects
  for i := 0 to FClassMappings.Count - 1 do
    TObject( FClassMappings.Objects[i] ).Free ;
  // Free FClassMappings
  FClassMappings.Free ;

  // Free any objects in the cache
  for i := 0 to FObjectCache.Count - 1 do begin
    try
      TObject( FObjectCache.Objects[i] ).Free ;
    except end ;
  end ;
  FObjectCache.Free ;

  // Call inherited
  inherited ;

end;

// Register a class mapping for a TObject descendant.
//------------------------------------------------------------------------------
procedure TtiFactory.RegisterClass(
                               const pStrClassID: string;
                               pClassRef: TObjectClassRef ;
                               const pBoolSingleton : boolean );
var i : integer ;
    lClassMapping : TClassMappingObject ;
    lStrClassID : string ;
begin
  lStrClassID := upperCase( pStrClassID ) ;

  // Does the class mapping alread exist?
  i := FClassMappings.IndexOf( lStrClassID );

  // If yes, report an error.
  // We do not raise an exception here as we may be inside an
  // initialization section.
  if i <> -1 then begin
    messageDlg( 'Registering a duplicate ' +
                'class mapping <' +
                pStrClassID + '>',
                mtInformation,
                [mbOK],
                0 ) ;
    Exit ; //==>
  end ;

  // Create the class mapping object
  lClassMapping := TClassMappingObject.CreateExt(
                      lStrClassID,
                      pClassRef,
                      pBoolSingleton ) ;

  // Add the class mapping object to the list
  FClassMappings.AddObject( upperCase( pStrClassID ),
                             lClassMapping ) ;

end;

// Register a class mapping for a TComponent descendant.
//------------------------------------------------------------------------------
procedure TtiFactory.RegisterClass(
                                  const pStrClassID: string;
                             pClassRef: TComponentClassRef ;
                             const pBoolSingleton : boolean = false );
var i : integer ;
    lClassMapping : TClassMappingComponent ;
    lStrClassID : string ;
begin
  lStrClassID := upperCase( pStrClassID ) ;

  // Does the class mapping already exist?
  i := FClassMappings.IndexOf( lStrClassID );

  // If yes, report an error.
  // We do not raise an exception here as we may be inside an
  // initialization section.
  if i <> -1 then begin
    messageDlg( 'Registering a duplicate ' +
                'class mapping <' +
                pStrClassID + '>',
                mtInformation,
                [mbOK],
                0 ) ;
    Exit ; //==>
  end ;

  // Create a classMapping object
  lClassMapping := TClassMappingComponent.CreateExt(
                      lStrClassID,
                      pClassRef,
                      pBoolSingleton ) ;

  // Add the ClassName, and ClassMapping object to the list
  FClassMappings.AddObject( upperCase( pStrClassID ),
                             lClassMapping ) ;

end;

// Either look up an existing instance of the object in the cache, or
// create a new one. DoCreateInstance should only be called from a concrete
// descendant of TFactoryAbstract.
//------------------------------------------------------------------------------
function TtiFactory.DoCreateInstance( const pStrClassID : string ; owner : TComponent = nil ) : TObject ;
var lIntCacheIndex   : integer ;
    lIntMappingIndex : integer ;
    lStrClassID      : string ;
    lClassMapping    : TClassMappingAbstract ;
begin

  // Get a temporary copy of ClassID, in upper case
  lStrClassID := upperCase( pStrClassID ) ;

  // Does the class mapping exist?
  lIntMappingIndex := FClassMappings.IndexOf( lStrClassID );

  // If not, then raise an exception
  // We can raise an exception here as we are not likely to be inside
  // initialization code
  if lIntMappingIndex = -1 then
    Raise Exception.Create( 'Request for invalid class ' +
                            'name <' +
                            pStrClassID + '>' +
                            ' Called by factory: ' +
                            ClassName ) ;

  // Is the object already in the cache?
  // Yes, then return the cahced copy
  // No, then create one
  lIntCacheIndex := FObjectCache.IndexOf( lStrClassID );

  // The object is not already in the cache
  if lIntCacheIndex = -1 then begin
    // Get a pointer to the correct class mapping
    lClassMapping := TClassMappingAbstract(
                FClassMappings.Objects[lIntMappingIndex] ) ;

    // Do we create this object as a TComponent or a TObject?
    if lClassMapping.CreateAs = caTComponent then
      result :=
        TClassMappingComponent( lClassMapping ).ClassRef.Create( owner )
    else
      result :=
        TClassMappingObject( lClassMapping ).ClassRef.Create ;

    // If this class is to be cached, then add it to the list
    if lClassMapping.Singleton then
      FObjectCache.AddObject( lStrClassID, result ) ;

  // The object is already in the cache
  end else begin
    // So return the existing copy
    result := FObjectCache.Objects[ lIntCacheIndex ] ;

  end ;

end ;

end.